home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / regist2a / regutil.bas < prev    next >
BASIC Source File  |  1999-04-19  |  7KB  |  188 lines
  1. Attribute VB_Name = "RegUtil"
  2. Option Explicit
  3.  
  4. Public Const FIND_KEY = &H1
  5. Public Const FIND_VALUE = &H2
  6. Public Const FIND_DATA = &H3
  7. Public Const HKEY_CLASSES_ROOT = &H80000000
  8. Public Const HKEY_CURRENT_USER = &H80000001
  9. Public Const HKEY_LOCAL_MACHINE = &H80000002
  10. Public Const HKEY_USERS = &H80000003
  11. Public Const KEY_NOTIFY = &H10
  12. Public Const READ_CONTROL = &H20000
  13. Public Const KEY_SET_VALUE = &H2
  14. Public Const KEY_CREATE_LINK = &H20
  15. Public Const KEY_CREATE_SUB_KEY = &H4
  16. Public Const KEY_ENUMERATE_SUB_KEYS = &H8
  17. Public Const SYNCHRONIZE = &H100000
  18. Public Const KEY_QUERY_VALUE = &H1
  19. Public Const STANDARD_RIGHTS_READ = (READ_CONTROL)
  20. Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
  21. Public Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
  22. Public Const STANDARD_RIGHTS_ALL = &H1F0000
  23. Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
  24. Public Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
  25. Public Const KEY_EXECUTE = (KEY_READ)
  26. Public Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
  27. Public Const STANDARD_RIGHTS_EXECUTE = (READ_CONTROL)
  28. Public Const READ_WRITE = 2
  29. Public Const ERROR_SUCCESS = 0&
  30. Public Const ERROR_NO_MORE_ITEMS = 259&
  31. Public Const MAX_PATH = 260
  32.  
  33. Type FILETIME
  34.         dwLowDateTime As Long
  35.         dwHighDateTime As Long
  36. End Type
  37.  
  38. Type ResultSet
  39.     varEntryList() As Variant
  40.     lngEntryCount As Long
  41. End Type
  42.  
  43. Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
  44.     
  45. Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias _
  46.     "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, _
  47.     ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, _
  48.     ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
  49.  
  50. Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
  51.     "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
  52.     ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
  53.     
  54. Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
  55.     "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
  56.     ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
  57.  
  58. Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
  59.     "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
  60.  
  61. Public udtResults As ResultSet
  62.  
  63.  
  64. Public Sub RegFind(ByVal strSearchItem As String, ByVal FindItem As Integer, _
  65.         blnFound As Boolean)
  66. On Error GoTo RegFind_Error
  67.  
  68. Dim lngResult As Long
  69. Dim hKey As Long
  70. Dim phkResult As Long
  71. Dim lpSubKey As String
  72.  
  73.     'Assume False
  74.     blnFound = False
  75.  
  76.     'Prepare result set
  77.     Erase udtResults.varEntryList()
  78.     ReDim udtResults.varEntryList(0)
  79.     udtResults.lngEntryCount = 0
  80.    
  81.     'Start at root
  82.     lpSubKey = ""
  83.  
  84.     Select Case FindItem
  85.         Case FIND_KEY
  86.             lngResult = RegOpenKeyEx(HKEY_CLASSES_ROOT, lpSubKey, &H0, KEY_READ, phkResult)
  87.             If lngResult = ERROR_SUCCESS Then
  88.                 Call RegFindKey(phkResult, UCase$(strSearchItem), lpSubKey)
  89.             End If
  90.             blnFound = udtResults.lngEntryCount > 0
  91.             lngResult = RegCloseKey(phkResult)
  92.             If lngResult <> ERROR_SUCCESS Then
  93.                 MsgBox "Can't close the key or key already closed"
  94.             End If
  95.         Case FIND_VALUE
  96.         Case FIND_DATA
  97.         Case Else
  98.             Err.Raise 500000, , "Invalid FIND criteria."
  99.     End Select
  100.     
  101.     
  102. Exit Sub
  103. RegFind_Error:
  104.  
  105.     MsgBox Err.Description, , "RegArbiter Error"
  106.     
  107. End Sub
  108.  
  109. Private Sub RegFindKey(ByVal hKey As Long, ByVal strSearchKey As String, lpSubKey As String)
  110. On Error GoTo RegFindKey_Error
  111.  
  112. Dim lngResultOpen As Long
  113. Dim phkResult As Long
  114. Dim lpSubKeyOpen As String
  115.  
  116. Dim lngResult As Long
  117. Dim dwIndex As Long
  118. Dim lpName As String
  119. Dim lpcbName As Long
  120. Dim lpClass As String
  121. Dim lpcbClass As Long
  122. Dim lpftLastWriteTime As FILETIME
  123. Dim Keys() As String
  124. Dim lngKeyCount As Long
  125.  
  126.     'Set up some parameters with preinitialized values dictated by the API docs.
  127.     dwIndex = 0&
  128.     lpName = String(MAX_PATH + 1, " ")
  129.     lpClass = String(MAX_PATH + 1, " ")
  130.     lpcbClass = MAX_PATH + 1
  131.     lpcbName = MAX_PATH + 1
  132.     
  133.     'Hold all key names
  134.     Erase Keys()
  135.     ReDim Keys(0)
  136.     lngKeyCount = 0
  137.     
  138.     'Iterate until we have no more keys
  139.     Do
  140.     
  141.         'Walk the keys below the current subkey
  142.         lngResult = RegEnumKeyEx(hKey, dwIndex, lpName, lpcbName, 0&, _
  143.             lpClass, lpcbClass, lpftLastWriteTime)
  144.         'Test for a match
  145.         If (InStr(UCase$(Left$(lpName, lpcbName)), strSearchKey)) Then
  146.             'A match!  Add to our global list
  147.             udtResults.lngEntryCount = udtResults.lngEntryCount + 1
  148.             ReDim Preserve udtResults.varEntryList(udtResults.lngEntryCount)
  149.             If lpSubKey = "" Then
  150.                 udtResults.varEntryList(udtResults.lngEntryCount - 1) = "HKEY_CLASSES_ROOT\" & _
  151.                    Left$(lpName, lpcbName)
  152.             Else
  153.                 udtResults.varEntryList(udtResults.lngEntryCount - 1) = "HKEY_CLASSES_ROOT\" & _
  154.                    lpSubKey & "\" & Left$(lpName, lpcbName)
  155.             End If
  156.         End If
  157.         
  158.         'Recurse
  159.         If lngResult = ERROR_SUCCESS Then
  160.             If lpSubKey = "" Then
  161.                 lpSubKeyOpen = Left$(lpName, lpcbName)
  162.             Else
  163.                 lpSubKeyOpen = lpSubKey & "\" & Left$(lpName, lpcbName)
  164.             End If
  165.             lngResultOpen = RegOpenKeyEx(HKEY_CLASSES_ROOT, lpSubKeyOpen, &H0, KEY_READ, phkResult)
  166.             If lngResultOpen = ERROR_SUCCESS Then
  167.                 Call RegFindKey(phkResult, strSearchKey, lpSubKeyOpen)
  168.                 lngResultOpen = RegCloseKey(phkResult)
  169.             End If
  170.         End If
  171.         
  172.         'Absolutely necessary to reinitialize parameters
  173.         lpName = String(MAX_PATH + 1, " ")
  174.         lpClass = String(MAX_PATH + 1, " ")
  175.         lpcbClass = MAX_PATH + 1
  176.         lpcbName = MAX_PATH + 1
  177.         dwIndex = dwIndex + 1&
  178.         
  179.     Loop While lngResult = ERROR_SUCCESS
  180.         
  181. Exit Sub
  182. RegFindKey_Error:
  183.  
  184.     'Something went wrong, close the Registry and get out!
  185.     lngResult = RegCloseKey(hKey)
  186.         
  187. End Sub
  188.